module H8Bit.BitmapFont ( BFBitmapFont (..)
                        , TextArray (..)
                        , ascii2c64
                        , advanceCursorDown
                        , bfChar
                        , bfDrawText
                        , bfLine
                        , bfLines
                        , bfMakeFont
                        , bfTextBox
                        , paintTextArray
                        , pokeChar
                        , taClrScr
                        , taFillWith
                        , taPutChar
                        , taPrintText
                        , taPrintTextLn
                        , mkTextArray
                        ) where

import Data.Array
import Data.Array.IO
import Data.Bits (xor)
import Data.Char (ord)
import Graphics.UI.SDL

import H8Bit.Tiles

data BFBitmapFont = BFBitmapFont {
      bfFontTiles :: Array Int Tile, -- ^ Array of character tiles
      bfFontWidth :: Int, -- ^ Width, redundant, but needed often
      bfFontHeight :: Int, -- ^ Height, redundant, but needed often
      bfFontConversion :: Char -> Int -- ^ A conversion function from Char to Int
}

-- | helper function for Tuples
forTuple f (a,b) (c,d) = ((f a c), (f b d))

-- | helper function for Tuples
-- bool4Tuple = uncurry (&&) . forTuple

-- ------------------------------------------------------------------

-- | Simple text array in order to be able to "print" Text normally...
data TextArray = TextArray {
  tarrayLeft :: Int,
  tarrayTop :: Int,
  tarrayCrsr :: IOArray Int Int,
  tarrayFill :: Char,
  tarrayTextArray :: IOArray (Int, Int) Char
}

mkTextArray :: Int -> Int -> Int -> Int -> Char -> IO TextArray
mkTextArray x y w h c = do
  crsr <- newArray (0, 1) 0
  TextArray x y crsr c `fmap` newArray ((0,0), (w-1,h-1)) c 


paintTextArray :: TextArray -> BFBitmapFont -> Surface -> IO Bool
paintTextArray arr font srf = 
  let fW = bfFontWidth font
      fH = bfFontHeight font
      x0 = tarrayLeft arr
      y0 = tarrayTop arr
      f ((x,y), c) = bfChar font (x0 + x * fW) (y0 + y * fH) c
  in getAssocs (tarrayTextArray arr) >>= (bfDrawText srf . map f)

pokeChar :: TextArray -> Int -> Int -> Char -> IO (Bool, Bool)
pokeChar ta x y c | x >= 0 && y >= 0 = do 
  let arr = tarrayTextArray ta
  ok <- (forTuple (<) (x, y) . snd) `fmap` getBounds arr
  if uncurry (&&) ok then writeArray arr (x, y) c >> return ok else return ok
                  | otherwise = return (False, False)

pokeCharUNSAFE :: TextArray -> Int -> Int -> Char -> IO ()
pokeCharUNSAFE ta x y c = writeArray (tarrayTextArray ta) (x, y) c

-- | Andvance the Cursor, returns False if it was wrapped
advanceCursor :: TextArray -> IO Bool
advanceCursor t = let arr = tarrayTextArray t
                      crsr = tarrayCrsr t
                  in do
                    maxx <- (fst . snd) `fmap` getBounds arr
                    x <- readArray crsr 0
                    let x' = (x + 1) `mod` (maxx + 1)
                    writeArray crsr 0 x'
                    return $ x' /= 0

advanceCursorDown :: TextArray -> IO Bool
advanceCursorDown t = let arr = tarrayTextArray t
                          crsr = tarrayCrsr t
                      in do
                        maxy <- (snd . snd) `fmap` getBounds arr
                        y <- readArray crsr 1
                        let y' = if y < maxy then y + 1 else y
                        writeArray crsr 1 y'
                        return $ y < maxy

cursorToBOL :: TextArray -> IO ()
cursorToBOL t = writeArray (tarrayCrsr t) 0 0

cursorToTop :: TextArray -> IO ()
cursorToTop t = writeArray (tarrayCrsr t) 1 0

-- | Advance the Cursor and change the line if it was wrapped. Returns
-- false if Cursor would fall of the screen.
advanceCursorWith :: TextArray -> IO Bool
advanceCursorWith t = advanceCursor t >>= check
  where check True = return True
        check False = advanceCursorDown t

taScrollUp :: TextArray -> IO ()
taScrollUp ta = let arr = tarrayTextArray ta
                    fill = repeat $ tarrayFill ta
                    f ((x, y), c) = writeArray arr (x, y - 1) c
                    remF ((_, y), _) = y /= 0
                in do
                  es <- getElems arr
                  (w, h) <- snd `fmap` getBounds arr
                  as <- filter remF `fmap` getAssocs arr
                  let tof = zip (zip [0..] $ repeat (h + 1)) $ fill
                  mapM_ f $ as ++ take (w + 1) tof


taPutChar :: TextArray -> Char -> IO ()
taPutChar ta c = do
  [x, y] <- getElems (tarrayCrsr ta)
  pokeCharUNSAFE ta x y c
  ok <- advanceCursorWith ta
  if ok then return () else taScrollUp ta
                   
taPrintText :: TextArray -> String -> IO ()
taPrintText t = mapM_ (taPutChar t)

taPrintTextLn :: TextArray -> String -> IO ()
taPrintTextLn t s = do
  mapM_ (taPutChar t) s 
  cursorToBOL t
  advanceCursorDown t >>= f
    where f True = return ()
          f False = taScrollUp t

taFillWith :: TextArray -> Char -> IO ()
taFillWith ta c = let arr = tarrayTextArray ta 
                      f (p, _) = writeArray arr p c
                  in do mapM_ f =<< getAssocs arr
                        

taClrScr :: TextArray -> IO ()
taClrScr ta = do cursorToTop ta
                 cursorToBOL ta
                 taFillWith ta (tarrayFill ta)
                 
-- ------------------------------------------------------------------


-- | Convert ASCII encoding to C64 charset screen encoding
ascii2c64 :: Char -> Int
ascii2c64 ch =  mod (a2c $ ord ch) 256
    where a2c c | c > 0x00 && c <= 0x1f = c + 0x60
                | c >= 0x60 && c <= 0x7f = c - 0x60
                | c `elem` [0x00, 0x40] = c `xor` 0x40
                | otherwise = c


-- ^ Make a font
bfMakeFont :: Int -> Int -> (Char -> Int) -> Surface -> BFBitmapFont
bfMakeFont w h f s = BFBitmapFont (tileSurfArr w h s) w h f

-- ^ bfLine creates a simple text line as a (Rect, Tile) pair
bfLine :: BFBitmapFont -- ^ Font
       -> Int -> Int -- ^ Target x and y position
       -> String -- ^ The text string
       -> [(Rect, Tile)]
bfLine f x y (t:ts) = bfChar f x y t : bfLine f (x + bfFontWidth f) y ts
bfLine _ _ _ [] = []


bfLines ::  BFBitmapFont -- ^ Font
        -> Int -> Int -- ^ Target x and y position
        -> [String] -- ^ The text strings
        -> [(Rect, Tile)]
bfLines f x y txt = foldl fld [] $ zip [0, fheight..] txt
    where fheight = bfFontHeight f
          fld rs (l, t) = rs ++ bfLine f x (y + l) t


bfTextBox :: BFBitmapFont -- ^ Font
       -> Int -- ^ Maximum text width (in characters)
       -> Int -> Int -- ^ Target x and y position
       -> String -- ^ The text string
       -> [(Rect, Tile)]
bfTextBox f tWidth x' y' txt' = cT x' y' txt'
    where maxx = x' + tWidth * bfFontWidth f
          cT x y txt@(t:ts) | x < maxx = bfChar f x y t : cT (x + bfFontWidth f) y ts
                            | otherwise = cT x' (y + bfFontHeight f) txt
          cT _ _ [] = []


bfChar :: BFBitmapFont
       -> Int -> Int -- ^ Target x and y position
       -> Char -- ^ The character
       -> (Rect, Tile)
bfChar f x y t = (Rect x y 0 0, bfFontTiles f ! bfFontConversion f t)

bfDrawText :: Surface -> [(Rect, Tile)] -> IO Bool
bfDrawText s ((r, Tile pos csurf):cs) = blitSurface csurf (Just pos) s (Just r)
                                           >> bfDrawText s cs
bfDrawText _ [] = return True
